HPAVC/HPAVC CD-ROM.iso/FUZZY.ZIP/DO_RESER.B

Text File | 1986-11-30 | 22KB | 688 lines

-------------------------------------------------------------------------------
--                                                                           --
--  Separate Unit:  Do_reserved -- process reserved predicates for Prover    --
--                                                                           --
--  Author:  Bradley L. Richards                                             --
--                                                                           --
--     Version     Date     Notes . . .                                      --
--    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
--       1.0    - - - - -   Never existed.  First version implemented after  --
--                            Parser et al reached version 2.0               --
--       2.0    20 Jun 86   Initial Version                                  --
--       2.05   13 Jul 86   Split into separate spec and package files       --
--       2.1    21 Jul 86   Demonstration version -- initial predicates      --
--                            implemented; initial debugging completed       --
--       2.2    28 Jul 86   Initial operational version -- 20 predicates     --
--                            implemented, plus lots of squashed bugs        --
--       2.3    19 Aug 86   Use AVL trees for rule_base, add many reserved   --
--                            predicates, and split output routines into     --
--                            package print_stuff.                           --
--       2.4    31 Aug 86   Do_reserved split out from Prover                --
--    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -    --
--                                                                           --
--  Description:  The procedure Do_reserved accepts Fuzzy Prolog reserved    --
--       predicates from Seek and processes them.  Most predicates have      --
--       their own subprocedure, but a few (e.g. asserta/assertz) are        --
--       combined.  After Do_reserved, all routines appear alphabetically.   --
--                                                                           --
-------------------------------------------------------------------------------

separate(prover)
procedure do_reserved( pred, goal_tree : AST_ptr; result_node : out AST_ptr;
            bindings : in out binding_list; level : natural;
                        failed : in out boolean ) is

    new_rule, new_rules, temp : AST_ptr;
    template : constant AST_ptr := new AST'(implication,
          new AST'(predicate, null, null), null, null, null);
    a_template : constant argument_ptr := new argument'(float_num, null, 0.0);
    file_ptr, value, value2, read_value : argument_ptr;
    temp_bindings : binding_list;
    int_arg, value_level, value2_level : integer;
    result_done : boolean := false;
    duplicate, not_found, unified : boolean;
    result : float := 0.0;


    procedure dr_assert is


        --
        --  Eval -- This set of three routines evalutes arguments.  Eval_args
        --          evalutes the arguments in a functor's argument list, and is
    --          the main routine called by dr_assert.  Eval evaluates a
    --          single argument, and eval_list evaluates the contents of
    --          a prolog list.
        --
        function eval_args( in_args : argument_ptr; bindings : binding_list;
                    level : natural ) return argument_ptr;

        function eval_list( in_list : p_list_ptr; bindings : binding_list;
                    level : natural ) return p_list_ptr;

        function eval( in_arg : argument_ptr; bindings : binding_list;
               level : natural ) return argument_ptr is
        value : argument_ptr;
        value_level : natural;
          begin
        lookup(in_arg, level, bindings, value, value_level);
        if value.is_a = predicate then
          return new argument'(predicate, null, value.name,
               eval_args(value.p_arguments, bindings, value_level));
        elsif value.is_a = prolog_list then
          return new argument'(prolog_list, null,
                  eval_list(value.list, bindings, value_level));
        else
          return new argument'(value.all);
        end if;
          end eval;

        function eval_args( in_args : argument_ptr; bindings : binding_list;
                    level : natural ) return argument_ptr is
        args : argument_ptr := in_args;
        new_arg : argument_ptr := null;
        new_args, temp : argument_ptr;
          begin
        while args /= null loop
          temp := eval(args, bindings, level);
          if new_arg = null then -- this is the first argument
            new_arg := temp;
            new_args := new_arg;
          else
            new_arg.next_arg := temp;
            new_arg := new_arg.next_arg;
          end if;
          new_arg.next_arg := null;
          args := args.next_arg;
        end loop;
        return new_args;
          end eval_args;

        function eval_list( in_list : p_list_ptr; bindings : binding_list;
                    level : natural ) return p_list_ptr is
        elts : p_list_ptr := in_list;
        new_elt : p_list_ptr := null;
        new_elts, temp : p_list_ptr;
          begin
        while elts /= null loop
          --
          --  Ada, in its infinite error checking, requires the following
          --  useless if statement in order to keep the discriminate static
          --
          if elts.has_tail then
            temp := new p_list'(true, eval(elts.elt, bindings, level), null);
          else
            temp := new p_list'(false, eval(elts.elt, bindings, level), null);
          end if;
          if new_elt = null then -- this is the first argument
            new_elt := temp;
            new_elts := new_elt;
          else
            new_elt.next_elt := temp;
            new_elt := new_elt.next_elt;
          end if;
          if elts.has_tail then
        new_elt.tail := eval(elts.tail, bindings, level);
        exit;
          else
            elts := elts.next_elt;
          end if;
        end loop;
        return new_elts;
      end eval_list;

      begin -- dr_assert
    if (pred.r_arguments = null) then
      error(no_pointer,"ASSERTA/Z called without any arguments");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      if pred.r_arguments.next_arg = null then -- use default truth of 1.0
        a_template.fp_num := 1.0;
        value2 := a_template;
      else
        lookup(pred.r_arguments.next_arg,level,bindings,value2,value2_level);
      end if;
      if value.is_a /= predicate then
        error(no_pointer, "first argument to ASSERTA/Z must be a functor");
        failed := true;
      elsif (value2.is_a /= float_num) or else (value2.fp_num < 0.0) or else
        (value2.fp_num > 1.0) then
        error(no_pointer,"2nd argument to ASSERTA/Z must be a fuzzy value");
        failed := true;
      else
        new_rule :=
        new AST'(implication,
             new AST'(predicate, value.name,
                 eval_args(value.p_arguments,bindings,value_level)),
             new AST'(fuzzy_value, value2.fp_num), null, null);
        add_node(rule_base, new_rule, duplicate);
        if duplicate then
          temp := fetch_node(rule_base, new_rule);
          if temp = null then
            update_node(rule_base, new_rule, not_found);
        if not_found then
          raise prover_error;
        end if;
          else
            if pred.predicate = rw_asserta then
              new_rule.next := temp;
              temp.prev := new_rule;
              update_node(rule_base, new_rule, not_found);
          if not_found then
            raise prover_error;
          end if;
            else
              while temp.next /= null loop
            temp := temp.next;
              end loop;
              temp.next := new_rule;
              new_rule.prev := temp;
            end if;
          end if;
        end if;
        result := 1.0;
          end if;
    end if;
      end dr_assert;


    procedure dr_call is
      begin
    if pred.r_arguments = null then
      error(no_pointer,"CALL requires one argument");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      if (value.is_a /= predicate) then
        error(no_pointer,"argument to CALL must be a functor");
        failed := true;
      else
        result_node :=
        new AST'(resolution_marker, value_level, threshold,
             new AST'(predicate, value.name, value.p_arguments));
        result_done := true;
      end if;
    end if;
      end dr_call;


    procedure dr_consult is

    rule_count : integer;

        --
        --  Append -- Used by consult to add rules to rule base.
        --
        procedure append(rule_base : in out tree_ptr; in_rules : AST_ptr;
             rule_count : out integer) is
        duplicate : boolean;
        next_rule, node : AST_ptr;
        new_rules : AST_ptr := in_rules;
        counter : integer := 0;
          begin
        while new_rules /= null loop
          next_rule := new_rules.next;
          new_rules.prev := null;
          new_rules.next := null;
          add_node(rule_base, new_rules, duplicate);
          if duplicate then
            node := fetch_node( rule_base, new_rules );
            if node /= null then
              while node.next /= null loop
                node := node.next;
              end loop;
              node.next := new_rules;
              new_rules.prev := node;
            else
              raise prover_error;
            end if;
          end if;
          new_rules := next_rule;
          counter := counter + 1;
        end loop;
        rule_count := counter;
          end append;


      begin -- dr_consult
    file_ptr := pred.r_arguments;
    while file_ptr /= null loop
      if file_ptr.is_a = predicate then
        put(file_ptr.name.name);
        start_parser(file_ptr.name.name, "");
        parse_file(new_rules);
        stop_parser;
        if number_of_errors = 0 then
          append(rule_base, new_rules, rule_count);
          result := 1.0;
          put(" has "); put(rule_count, 1); put(" rules");
        else
          put(file_ptr.name.name & " ignored");
          failed := true;
        end if;
        new_line;
      else
        put_line("invalid file name");
        failed := true;
      end if;
      file_ptr := file_ptr.next_arg;
    end loop;
      end dr_consult;


    procedure dr_fuzzy is
      begin
    if pred.r_arguments = null then
      error(no_pointer,"FUZZY requires one argument");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      if value.is_a = float_num then
        if (value.fp_num < 0.0) or (value.fp_num > 1.0) then
          error(no_pointer, "value to FUZZY out of range");
          failed := true;
        else
          result := value.fp_num;
        end if;
      elsif value.is_a = variable then
        a_template.fp_num := current_truth;
        unify_arg(value, a_template, value_level, level, bindings, unified);
        result := current_truth;
        if not unified then
          raise prover_error;
        end if;
      else
        error(no_pointer, "invalid node type to FUZZY");
        failed := true;
      end if;
    end if;
      end dr_fuzzy;


    procedure dr_listing is
      begin
    if pred.r_arguments = null then
      error(no_pointer,"LISTING requires one argument");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      if value.is_a /= predicate then
        error(no_pointer,"argument to LISTING must be a functor");
      else
        template.head.name := value.name;
        temp := fetch_node(rule_base, template);
        if temp /= null then
          while temp /= null loop
            print_clause(temp);
            temp := temp.next;
          end loop;
          result := 1.0;
        end if;
      end if;
    end if;
      end dr_listing;


    procedure dr_log is
      begin
    if (pred.r_arguments = null) or else
       (pred.r_arguments.next_arg = null) then
      error(no_pointer, "LN/LOG requires two arguments");
      failed := true;
    else
      lookup(pred.r_arguments,level,bindings,value,value_level);
      lookup(pred.r_arguments.next_arg,level,bindings,value2,value2_level);
      if value.is_a = variable then
        case value2.is_a is
          when variable =>
        error(no_pointer,"both arguments to LN/LOG uninstantiated");
        failed := true;
          when float_num =>
        if pred.predicate = rw_ln then
          a_template.fp_num := exp(value2.fp_num);
        else -- rw_log
          a_template.fp_num := 10.0 ** value2.fp_num;
        end if;
          when integer_num =>
        if pred.predicate = rw_ln then
          a_template.fp_num := exp(float(value2.int_num));
        else -- rw_log
          a_template.fp_num := 10.0 ** float(value2.int_num);
        end if;
          when others =>
        error(no_pointer,"2nd argument to LN/LOG is an invalid type");
        failed := true;
          end case;
        if not failed then
          unify_arg(value,a_template,value_level,level,bindings,unified);
          if unified then
        result := 1.0;
          else
        raise prover_error;
          end if;
        end if;
      elsif (value.is_a = float_num) or (value.is_a = integer_num) then
        if value.is_a = float_num then
          if pred.predicate = rw_ln then
            a_template.fp_num := nat_log(value.fp_num);
          else -- rw_log
            a_template.fp_num := com_log(value.fp_num);
          end if;
        else -- integer_num
          if pred.predicate = rw_ln then
            a_template.fp_num := nat_log(float(value.int_num));
          else -- rw_log
            a_template.fp_num := com_log(float(value.int_num));
          end if;
        end if;
        case value2.is_a is
          when variable =>
            unify_arg(value2,a_template,value2_level,level,bindings,unified);
        if unified then
          result := 1.0;
        else
          raise prover_error;
        end if;
          when float_num =>
        if a_template.fp_num = value2.fp_num then
          result := 1.0;
        end if;
          when integer_num =>
        if a_template.fp_num = float(value2.int_num) then
          result := 1.0;
        end if;
          when others =>
        error(no_pointer,"2nd argument to LN/LOG is an invalid type");
        failed := true;
          end case;
      else
        error(no_pointer,"1st argument to LN/LOG is an invalid type");
        failed := true;
      end if;
    end if;
      end dr_log;


    procedure dr_parse is
      begin
    file_ptr := pred.r_arguments;
    while file_ptr /= null loop
      if file_ptr.is_a = predicate then
        put(file_ptr.name.name & ' ');
        start_parser(file_ptr.name.name, (file_ptr.name.name & ".lst"));
        parse_file(new_rules);
        stop_parser;
        put_line("contains:");
        put(number_of_errors); put_line(" errors");
        put(number_of_warnings); put_line(" warnings");
        put(number_of_notes); put_line(" notes");
        result := 1.0;
      else
        error(no_pointer, "invalid file name");
        failed := true;
      end if;
      file_ptr := file_ptr.next_arg;
    end loop;
      end dr_parse;


    procedure dr_put_tab is
      begin
    if pred.r_arguments = null then
      error(no_pointer,(pred.name.name & " requires one argument"));
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      if (value.is_a /= integer_num) and (value.is_a /= float_num) then
        if pred.predicate = rw_put then
          error(no_pointer, "nonnumeric argument to PUT");
        else
          error(no_pointer, "nonnumeric argument to TAB");
        end if;
        failed := true;
      else
        if value.is_a = integer_num then
          int_arg := value.int_num;
        else -- fp
          int_arg := integer(value.fp_num + 0.00001);
        end if;
        if pred.predicate = rw_put then
          put(character'val(int_arg));
        else
          for i in 1..int_arg loop
            put(' ');
          end loop;
        end if;
        result := 1.0;
      end if;
    end if;
      end dr_put_tab;


    procedure dr_read is
    eof : boolean;
      begin
    if pred.r_arguments = null then
      error(no_pointer,"READ requires one argument");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      start_parser("", "");
      parse_read(read_value, eof);
      stop_parser;
      if (number_of_errors = 0) and (not eof) then
        unify_arg(value, read_value, value_level, level, bindings, unified);
        if unified then
          result := 1.0;
        end if;
      else
        failed := true;  -- errors have already been displayed to screen
      end if;
    end if;
      end dr_read;


    procedure dr_reset is
      begin
    release(rule_base);
    rule_base := init_tree;
    put_line("rule base reinitialized");
    result := 1.0;
      end dr_reset;


    procedure dr_retract is
      begin
    --
    --  This retract logic has one inherent, insidious bug.  Clauses which
    --  have been retracted from the rule base may still be pointed to by
    --  db_ptr in various instantiations of Seek already on the call stack.
    --  There appears to be no way to fix this without major program
    --  restructuring.  This problem should not arise too often, but
    --  in hopes of mitigating potential damages RETRACT does not
    --  deallocate retracted rules.
    --
    if pred.r_arguments = null then
      error(no_pointer,"RETRACT requires one argument");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
      if value.is_a /= predicate then
        error(no_pointer,"argument to RETRACT must be a functor");
        failed := true;
      else
        template.head.name := value.name;
        template.head.p_arguments := value.p_arguments;
        temp := fetch_node(rule_base, template);
        unified := false;
        while temp /= null loop
          temp_bindings := bindings;
          unify(template.head, temp.head, value_level, integer'last,
            temp_bindings, unified);
          if unified then
        bindings := temp_bindings;
        exit;
          else
            release(temp_bindings, bindings); -- the bindings aren't valid
          end if;
          temp_bindings := bindings;
          temp := temp.next;
        end loop;
        if unified then
          if temp.prev = null then -- the first node, so must update
        if temp.next = null then
          delete_node(rule_base, temp, not_found);
        else
          temp.next.prev := null;
          temp := temp.next;
          update_node(rule_base, temp, not_found);
        end if;
        if not_found then
          raise prover_error;
        end if;
          else
        temp.prev.next := temp.next;
        if temp.next /= null then
          temp.next.prev := temp.prev;
        end if;
          end if;
          result := 1.0;
        else
          failed := true;
        end if;
      end if;
    end if;
      end dr_retract;


    procedure dr_threshold is
      begin
    if pred.r_arguments = null then
      error(no_pointer,"THRESHOLD requires one argument");
      failed := true;
    else
      lookup(pred.r_arguments, level, bindings, value, value_level);
          if value.is_a = variable then -- set variable to current threshold
        unify_arg(value, new argument'(float_num, null, threshold),
              value_level, level, bindings, unified);
          result := 1.0;
        if not unified then
          raise prover_error;
        end if;
          elsif value.is_a = float_num then -- set the search threshold
            threshold := value.fp_num;
            result_node := new AST'(threshold_marker, 1.0, threshold);
        current_truth := 1.0;  -- must complete our result here
        result_done := true;
      else
        error(no_pointer, "invalid argument to THRESHOLD");
        failed := true;
          end if;
    end if;
      end dr_threshold;


    procedure dr_trace is
      begin
    if  pred.predicate = rw_trace then
      trace(true);
    else -- rw_notrace
      trace(false);
    end if;
    result := 1.0;
      end dr_trace;


    procedure dr_types is
      begin
    lookup(pred.r_arguments, level, bindings, value, value_level);
    result := 0.0;
    case value.is_a is
      when integer_num =>
        if (pred.predicate = rw_integer) or
           (pred.predicate = rw_number) or
           (pred.predicate = rw_atomic) or
           (pred.predicate = rw_nonvar) then
          result := 1.0;
        end if;
      when float_num =>
        if (pred.predicate = rw_float) or
           (pred.predicate = rw_number) or
           (pred.predicate = rw_atomic) or
           (pred.predicate = rw_nonvar) then
          result := 1.0;
        end if;
      when character_lit =>
        if (pred.predicate = rw_atomic) or
           (pred.predicate = rw_nonvar) then
          result := 1.0;
        end if;
      when predicate =>
        if (pred.predicate = rw_atom) or
           (pred.predicate = rw_atomic) or
           (pred.predicate = rw_nonvar) then
          result := 1.0;
        end if;
      when prolog_list =>
        if (pred.predicate = rw_nonvar) then
          result := 1.0;
        end if;
      when variable =>
        if (pred.predicate = rw_var) then
          result := 1.0;
        end if;
    end case;
    if result = 0.0 then
      failed := true;
    end if;
      end dr_types;


  begin -- do_reserved

    --
    --  Call the proper routine for this reserved word.  A few very simple
    --  cases are handled within this procedure (for example "cut").
    --
    case pred.predicate is
      when cut => result := 1.0;  -- "cut" logic really appears in Seek
      when rw_asserta | rw_assertz => dr_assert;
      when rw_call => dr_call;
      when rw_consult =>  dr_consult;
      when rw_fail => failed := true;
      when rw_fuzzy => dr_fuzzy;
      when rw_listing => dr_listing;
      when rw_ln | rw_log => dr_log;
      when rw_nl => new_line;
            result := 1.0;
      when rw_parse => dr_parse;
      when rw_put | rw_tab => dr_put_tab;
      when rw_read => dr_read;
      when rw_repeat => result := 1.0;  -- real logic appears in Seek
      when rw_reset => dr_reset;
      when rw_retract => dr_retract;
      when rw_threshold => dr_threshold;
      when rw_trace | rw_notrace => dr_trace;
      when rw_true => result := 1.0;
      when rw_var | rw_nonvar | rw_atom |
       rw_atomic | rw_number | rw_integer | rw_float => dr_types;
      when rw_write =>
    print_argument(pred.r_arguments, bindings, level, no_quote);
    result := 1.0;
      when others => put(pred.predicate); new_line;
    error(no_pointer, "reserved predicate not implemented");
    failed := true;
    end case;
    if not result_done then
      current_truth := result;
      result_node := new AST'(fuzzy_value, result);
    end if;

  exception
    when name_error => -- this happens in consult, parse, and reconsult
      failed := true;
      put_line("not found--predicate aborted at this point");

  end do_reserved;